home *** CD-ROM | disk | FTP | other *** search
/ The Programmer Disk / The Programmer Disk (Microforum).iso / xpro / pascal2 / pro20 / calendar.p < prev    next >
Text File  |  1986-01-04  |  3KB  |  109 lines
  1. {Include File Calender.P}
  2. {From PCTJ, Dec 85, p.142}
  3. {michael Covington}
  4.  
  5. { long range calendrical package in standard pascal }
  6. { Copyright 1985 Micheal A. Covington               }
  7.  
  8. (*
  9. function Frac(x:real):real 
  10.   {fractional part of a whole number }
  11.   {Turbo pascal provides this as a built-in function}
  12. begin
  13.   while x < maxint do x := x + maxint;
  14.   while x > do x := x - maxint;
  15.   frac := x - trunc(x)
  16. end;
  17. *)
  18.  
  19. (*
  20. function int(x:real):real;
  21.   { integer part of a real number. }
  22.   { uses real data type to accomodate large numbers }
  23.   { Turbo Pascal provides this as a built in function }
  24. begin
  25.   int := x - frac(x)
  26. end;
  27. *)
  28.  
  29. function floor(x:real):real;
  30.   {largest whole number not greater than x}
  31.   {uses real data type to accomodate large numbers}
  32. begin
  33.   if (x<0) and (frac(x)  <> 0) then
  34.     floor := int(x) - 1.0
  35.   else
  36.    floor := int(x)
  37. end;
  38.  
  39. function daynumber(year, month, day: integer):real;
  40.   { number of days elapsed since 1980 January 0 (1979 December 31). }
  41.   { Note that the year should be given as 1985, not just 85. }
  42.   { Switches from Julian to Geregorian calendar on Oct 15, 1582. }
  43. var
  44.   y,m: integer;
  45.   a,b,d : real;
  46. begin
  47.   if year < 0 then y := year + 1
  48.               else y := year;
  49.   m := month;
  50.   if month < 3 then
  51.     begin
  52.       m := m + 12;
  53.       y := y - 1;
  54.     end;
  55.   d := floor(365.25*y) + int(30.60001*(m+1)) + day - 723244.0;
  56.   if d < -145068.0 then
  57.     {julian calendar}
  58.     daynumber := d
  59.   else begin
  60.     { convert to Gregorian calendar }
  61.     a := floor(y/100.0);
  62.     b := 2 - a + floor(a/4.0);
  63.     daynumber := d + b;
  64.   end
  65. end;
  66.  
  67. procedure caldate(date:real; var year, month, day : integer);
  68.   { inverse of daynumber; given date, finds year, month, and day. }
  69.   { uses readl arithmetic becuase numbers are too big for integers }
  70. var
  71.   a,aa,b,c,d,e,z: real;
  72.   y : integer;
  73. begin
  74.   z := int(date + 2444239.0);
  75.   if date < -145078.0 then
  76.     {julian calendar}
  77.     a := z
  78.   else
  79.     {gregorian calendar}
  80.     begin
  81.       aa := floor((z - 1867216.25)/36524.25);
  82.       a := z + 1 + aa - floor(aa/4.0)
  83.     end;
  84.   b := (a + 1524.0);
  85.   c := int((b-122.1)/365.25);
  86.   d := int(365.25*c);
  87.   e := int((b-d)/30.6001);
  88.   day := trunc(b-d-int(30.6001*e));
  89.   if e > 13.5 then month := trunc(e - 13.0)
  90.               else month := trunc(e - 1.0);
  91.   if month > 2 then y := trunc(c - 4716.0)
  92.                else y := trunc(c - 4715.0);
  93.   if y < 1 then year := y - 1
  94.            else year := y
  95. end;
  96.  
  97. function weekday(date:real):integer;
  98.   { given day number as used in above routines,  }
  99.   { finds day of week (1 = Sunday, 2 = monday, etc). }
  100. var
  101.   dd : real;
  102. begin
  103.   dd := date;
  104.   while dd > 28000.0 do dd := dd - 28000.0;
  105.   weekday := ((trunc(dd) + 1) mod 7) + 1
  106. end;
  107.  
  108.  
  109.